#|_____________________________________________________________________
 |
 | dissobj.lsp
 | Copyright (c) 1991-2002 by Forrest W. Young
 | This file contains code to implement dissimilarity data objects
 | and the dissimilarity data object supervisor
 |_____________________________________________________________________
 |#

;(require "vista")

;;########################################################################
;;define prototype dissimilarity data object and it's isnew method
;;prototype inherits from multivariate data-object prototype
;;########################################################################


;;constructor function for dissimilarity (matrix) data
                                                                                              (defun matrix-data (data variables title labels types matrices shapes
                         element-labels name extension subordinate 
                         &optional supervisor)
  (if supervisor
      (send diss-data-supervisor-proto :new
            data variables title labels types matrices shapes element-labels 
            name extension  subordinate)
      (send diss-data-object-proto :new
            data variables title labels types matrices shapes element-labels 
            name extension  subordinate)))

#|The following function appears in dataobj2.lsp
(defproto diss-data-object-proto 
  '(enames mshapes nmat nele mat-window mat-window-object mat-states) 
  () mv-data-object-proto)|#

(defmeth diss-data-object-proto :isnew 
  (data variables title labels types matrices shapes element-labels 
        name extension subordinate) 
  (send self :initialize-diss-object
        data variables title labels types matrices shapes element-labels 
        name extension subordinate))

(defmeth diss-data-object-proto :statistical-object-type (&optional (logical nil set))
;written this way to prevent changing slot to invalid value
    (setf (slot-value 'statistical-object-type) "diss")
    (slot-value 'statistical-object-type))


;body of isnew was the following, but was changed so that 
;diss-based plugins, which inherit from mv-data, would be
;able to use the method 


(defmeth mv-data-object-proto :element-labels (&optional (names nil set))
  (unless (send self :has-slot 'enames) (send self :add-slot 'enames))
  (if set (setf (slot-value 'enames) names))
  (slot-value 'enames))



(defmeth mv-data-object-proto :shapes  (&optional (names nil set))
  (unless (send self :has-slot 'shapes) (send self :add-slot 'shapes))
  (if set (setf (slot-value 'shapes) names))
  (slot-value 'shapes))


(defmeth mv-data-object-proto :nmat (&optional (number nil set))
  (unless (send self :has-slot 'nmat) (send self :add-slot 'nmat))
  (if set (setf (slot-value 'nmat) number))
  (slot-value 'nmat))

(defmeth mv-data-object-proto :nele (&optional (number nil set))
  (unless (send self :has-slot 'nele) (send self :add-slot 'nele))
  (if set (setf (slot-value 'nele) number))
  (slot-value 'nele))

(defmeth mv-data-object-proto :mat-window (&optional (number nil set))
  (unless (send self :has-slot 'mat-window) (send self :add-slot 'mat-window))
  (if set (setf (slot-value 'mat-window) number))
  (slot-value 'mat-window))

(defmeth mv-data-object-proto :mat-states (&optional (number nil set))
  (unless (send self :has-slot 'mat-states) (send self :add-slot 'mat-states))
  (if set (setf (slot-value 'mat-states) number))
  (slot-value 'mat-states))

(defmeth mv-data-object-proto :initialize-diss-object
  (data variables title labels types matrices shapes element-labels 
        name extension subordinate) 
  (unless (send self :statobj-start-time) 
          (send self :statobj-start-time (get-internal-real-time)))
  (let* ((nmat (length matrices))
         (nele (^ (length variables) 2))
         )
    (when (send self :initialize-object data variables title labels types name)
          (send self :statistical-object-type "diss")
          (send self :extension extension)
          (send self :subordinate subordinate)
          (unless (send self :data)
                  (send self :data 
                        (combine (transpose (matrix (list nmat nele) data))))  )                   
          (send self :nmat nmat)
          (send self :nele nele)
          (send self :matrices  matrices)
          (send self :mat-window nil)
          (send self :mat-states (repeat 'normal nmat))
          (if shapes (send self :shapes shapes)
             (send self :shapes 
             (mapcar #'(lambda (x) (format nil "Symmetric" x)) (iseq nmat))))
          (send self :element-labels
             (if element-labels element-labels
                (mapcar #'(lambda (x) (format nil "Elem~a" x)) (iseq nele))))
          (send self :labels
                (if labels labels (repeat variables nmat)))
          
          (send self :elapsed-time
              (/ (- (get-internal-real-time) (send self :statobj-start-time))
                 internal-time-units-per-second))
          t)))


      

    

;;--------------------------------------------------------------------------
;;define slot-accessor methods for the dissimilarity data-object
;;--------------------------------------------------------------------------

(defmeth diss-data-object-proto :nmat (&optional (number nil set))
  (if set (setf (slot-value 'nmat) number))
  (slot-value 'nmat))

(defmeth diss-data-object-proto :nele (&optional (number nil set))
  (if set (setf (slot-value 'nele) number))
  (slot-value 'nele))

(defmeth diss-data-object-proto :mat-window (&optional (logical nil set))
  (if set (setf (slot-value 'mat-window) logical))
  (slot-value 'mat-window))

(defmeth diss-data-object-proto :mat-window-object (&optional (object nil set))
  (if set (setf (slot-value 'mat-window-object) object))
  (slot-value 'mat-window-object))

(defmeth diss-data-object-proto :mat-states (&optional (list nil set))
"Message args: (&optional list)
 Sets or retrieves the selection states of the matrices in the dissimilarity
 data object. States mimic point selection states (normal, selected, invisible)." 
  (if set (setf (slot-value 'mat-states) list))
  (slot-value 'mat-states))

(defmeth diss-data-object-proto :get-mat-states ()
  (send *obs-window* :point-state (iseq (send *obs-window* :num-points))))

(defmeth diss-data-object-proto :shapes  (&optional (names nil set))
  (if set (setf (slot-value 'mshapes) names))
  (slot-value 'mshapes))

(defmeth diss-data-object-proto :active-shapes (ok-types)
  (select (send self :shapes) (send self :current-matrices ok-types)))

(defmeth diss-data-object-proto :active-matrices (ok-types)
"Message args: (&optional strings)
Sets or retrieves the names of active ok-type matrices in dissimilarity data.
An active matrix is one which is selected in the mat-window, or if none 
selected, which is visible in the window.  Ok-types must be one of the 
following strings: all, symmetric, asymmetric, rectangular."
  (select (send self :matrices) (send self :current-matrices ok-types)))

(defmeth diss-data-object-proto :active-nmats (ok-types)
  (length (send self :active-matrices ok-types)))

(defmeth diss-data-object-proto :element-labels (&optional (names nil set))
  (if set (setf (slot-value 'enames) names))
  (slot-value 'enames))

(defmeth diss-data-object-proto :active-data (ok-types)
    (combine (send self :active-data-matrix ok-types)))

(defmeth diss-data-object-proto :active-data-matrix (ok-types)
"Message args: (ok-types)
Reports, for ok-types variables which are active, the dissimilarity data in multivariate matrix form. An active variable is one which is selected in the 
var-window, or if none selected, which is visible in the window.  Ok-types 
must be one of the following strings: all, numeric, ordinal, category, label."
  (select (send self :data-matrix) (iseq (send self :nele))
       (send self :current-matrices ok-types)))

(defmeth diss-data-object-proto :data-matrix ()
"Message args: none
Returns the dissimilarity data as a matrix in internally stored multivariate format."
  (let* ((n (send self :nmat))
         (m (send self :nele)))
         (matrix (list m n) (send self :data))))

(defmeth diss-data-object-proto :data-by-matrix ()
"Message args: none
Returns the dissimilarity data as a list of all data elements, the first n-squared elements are the row-wise list of elements of the first nXx matrix, the second n-squared elements are the row-wise list of elements of the second nXn matrix, etc."
  (combine (transpose (send self :data-matrix))))

(defmeth diss-data-object-proto :get-matrix (k)
"Message arg: (matrix-number)
Requires an integer denoting the position of the dissimilarity data matrix
in the data-list. Returns the matrix in dissimilarity form."
  (let ((nvar (send self :nvar))
        (nele (send self :nele))
        (nmat (send self :nmat))
        )
    (matrix (list nvar nvar) 
            (combine (col (matrix (list nele nmat) (send self :data)) k)))
    ))

(defmeth diss-data-object-proto :get-matrices (q)
"Message arg: (matrix-number-list)
Reguires a list of integers denoting the positions of the dissimilarity
data matrices in the data-list.  Returns the matrices in dissimilarity form."
  (let ((request (repeat "g" (length q))))
       (dotimes (i (length q))
         (setf (select request i) (send self :get-matrix (select q i))))   
         request))

(defmeth diss-data-object-proto :active-labels ()
"Message args: none
Reports the labels (names) of the active variables (rows and columns of a matrix).  Active variables are those which are selected in the var-window, or if none are selected, which are visible in the window."
  (send self :active-variables '(all)))

(defmeth diss-data-object-proto :get-active-matrix (k ok-var-types)
"Message arg: (matrix-number ok-var-types)
Requires an integer denoting the position of the dissimilarity data matrix
in the data-list and a list of ok-type variables. Returns a matrix containng the rows and columns of matrix k that correspond to the active ok-var-type variables."
  (let ((current-vars (send self :current-variables ok-var-types)))
    (select (send self :get-matrix k) current-vars current-vars) ))

(defmeth diss-data-object-proto :get-active-data-matrices ()
"Message args: none
Returns a list of dissimilarity matrices (in dissimilarity form) consisting of the active matrices, where each returned matrix contains only the active numeric rows and columns of each data matrix."
  (let* ((q (send self :current-matrices '(symmetric asymmetric)))
         (nmat (length q))
         (request (iseq nmat)))
    (dotimes (i nmat)
             (setf (select request i) 
                   (send self :get-active-matrix (select q i) '(numeric))))  
         request))

(defmeth diss-data-object-proto :get-active-data-rows ()
"Returns a list of vectors, one vector for each row of entire data. "
  (let* ((data (send self :get-active-data-matrices))
         (nmat (send self :nmat))
         (all-row-vecs)
         )
    (mapcar #'(lambda (datamat)
                (setf all-row-vecs 
                      (append all-row-vecs (row-list datamat))))
            (send self :get-active-data-matrices))
    all-row-vecs))

;;-------------------------------------------------------------------------
;;define menu methods for the dissimilarity data-object
;;-------------------------------------------------------------------------


 (defmeth diss-data-object-proto :create-data 
	(&optional name &key (hidden nil hidden?) (iconify t iconify?))
"Message args: (&optional name)
Creates a new data object from the current active data.  The data object is
named NAME (a string) if specified, otherwise a dialog is presented for name.
Only the active symmetric or asymmetric matrices are used, and only the active numeric variables in each active matrix are used. Returns the object identification of the new data object."
  (if (not (eq current-data self)) (setcd self))
  (setf merge-dob nil)
  (let ((menu-name nil)
        (iconify 
         (cond 
           ((and hidden? iconify?)
            (error "cannot use both hidden and iconify"))
           (hidden? (not hidden))
           (iconify? iconify)
           (t)))
        (initial-name (strcat "CC|" (send self :name)))
        (data (send self :active-data '(all)))
        (matrices (send self :active-matrices '(all))))
    (if name
        (setf menu-name name)
        (setf menu-name (get-string-dialog "Name of the New Data Object:"
                                           :initial initial-name)))
    (cond 
      (menu-name 
       (data menu-name
             :created (send *workmap* :selected-icon)
             :matrices matrices
             :shapes  (send self :active-shapes '(symmetric asymmetric))
             :title   (concatenate 'string "Created from "(send self :title))
             :data    (combine (send self :get-active-data-matrices))
             :variables (send self :active-variables '(numeric))
             :labels  (send self :active-labels)
             :types   (send self :active-types '(numeric))
             :iconify iconify
             )))))

(defmeth diss-data-object-proto :visualize (&key dialog) 
  (if (not (eq current-data self)) (setcd self))
  (error-message "Visualization not supported for dissimilarity data. Instead, you can perform a Multidimensional Scaling, and then visualize the MDS model of the data.")
  t)

 
(defmeth diss-data-object-proto :current-matrices (ok-shapes)
"Args: (list) 
Takes a list of matrix shapes and returns a list of indices
of the matrices of those shapes which are also visible (if any
matrices are selected, visible AND selected) in the variables window.
Shapes can be Symmetric, Asymmetric or Rectangular, or All 
(which means select all shapes of matrices)."
  (let* ((nmat (send self :nmat))
         (states (send self :mat-states))
         (selected-matrices 
          (which (mapcar #'equal (repeat 'SELECTED nmat) states)))
         (shapes  (send self :shapes))
         (rectangular-matrices ())
         (symmetric-matrices ())
         (asymmetric-matrices ())
         )
    (setf shapes (mapcar #'string-downcase shapes))
    (if (member 'rectangular ok-shapes) 
        (setf rectangular-matrices 
         (which (mapcar #'equal (repeat '"rectangular" nmat) 
                        shapes))))
    (if (member 'symmetric ok-shapes) 
        (setf symmetric-matrices 
         (which (mapcar #'equal (repeat '"symmetric" nmat) 
                        shapes))))
    (if (member 'asymmetric ok-shapes) 
        (setf asymmetric-matrices 
         (which (mapcar #'equal (repeat '"asymmetric" nmat) 
                        shapes))))
    (if (member 'all ok-shapes)
        (setf symmetric-matrices (iseq nmat)))
    (if (equal selected-matrices nil) 
        (setf selected-matrices
             (which (mapcar #'not (mapcar #'equal 
                    (repeat 'INVISIBLE nmat) states)))))
    (setf selected-matrices 
        (intersection selected-matrices 
           (union rectangular-matrices  
                  (union symmetric-matrices asymmetric-matrices))))
    (if selected-matrices (sort-data selected-matrices)
        nil)))

(defmeth diss-data-object-proto :save-data-template (f)
  (unwind-protect
   (print 
    `(data ,(send self :name)
           :title      ,(send self :title)
           :about      ,(send self :about)
           :variables ',(send self :active-variables '(numeric))
           :types     ',(send self :active-types '(numeric))
           :labels    ',(send self :active-labels)
           :matrices  ',(send self :active-matrices '(all))
           :shapes    ',(send self :active-shapes '(all))
           :data      ',(combine (send self :get-active-data-matrices))
           :datasheet-arguments ',(send self :datasheet-arguments))
    f)))

(defmeth diss-data-object-proto :active-nmat (ok-shapes)
"Args: (list)
Takes a list of matrix shapes and returns the number of active matrices of that shape."
  (length (send self :current-matrices ok-shapes)))

(defun merge-matrices (&optional name) 
  (send current-data :merge-matrices name))

(defmeth diss-data-object-proto :merge-matrices (&optional name)
(if (not (eq current-object self)) (setcd self))
  (let ((object nil)
        (prev-data-icon (send previous-data :icon-number))
        (menu-name nil)
        )
    (cond 
      ((/= (send self :active-nvar '(all)) 
           (send previous-data :active-nvar '(all)))
           (error-message "Data Matrices cannot be merged because they do not have the same number of columns."))
      (t
       (if name
           (setf menu-name name)
           (setf menu-name 
                 (get-string-dialog "Please Name the Created Data Matrix:"
                                    :initial "Unnamed")))
       (cond 
         (menu-name 
          (setf object 
                (data menu-name
                      :title (strcat "Merger of " (send self :title)
                             " with " (send previous-data :title))
                      :created (send *workmap* :selected-icon)  
                      :variables (send self :active-variables '(all))
                      :types (send self :active-types '(all))
                      :labels (send self :active-variables '(all))
                      :matrices 
                      (combine (send self :active-matrices'(all)) 
                               (send previous-data :active-matrices '(all)))
                      :shapes 
                      (combine (send self :active-shapes '(all))
                               (send previous-data :active-shapes '(all)))
                      :data 
                      (combine 
                       (send self :get-active-data-matrices)
                       (send previous-data :get-active-data-matrices))))
          (send *workmap* :connect-icons 
                (- prev-data-icon 1) 
                (- (send *workmap* :num-icons) 1) :new t)
          (send object :dob-parents (add-element-to-list 
                 (send object :dob-parents) previous-data))
          (send previous-data :dob-children (add-element-to-list 
                 (send previous-data :dob-children) object))
         ))))
    object))

;added next method fwy4.25
(defmeth diss-data-object-proto :select-matrices (mat-name-list)
"Args: MAT-NAME-LIST
Selects the matrices in MAT-NAME-LIST from the list of matrix names.  Displays the selection in the mats window when it is open."
  (if (not (eq current-data self)) (setcd self))
  (let* ((w (send *vista* :mat-window-object))
         (mat-num-list ($position mat-name-list (send self :matrices)))
         (states (repeat 'NORMAL (send self :nmat)))
         )
    (cond 
      (w (send w :selection mat-num-list)
         (send self :mat-states 
               (send w :point-state (iseq (send w :num-points)))))
      (t (setf (select states mat-num-list)
                     (repeat 'SELECTED (length mat-num-list)))
         (send self :mat-states states)))))


(defmeth diss-data-object-proto :report(&optional unused w)
"Method Args: none
Presents a numeric listing of the data."
  (if (not (eq current-data self)) (setcd self))
  (send self :print-diss-data w))

(defmeth diss-data-object-proto :print-diss-data (w)
  (let* ((data (send self :data))
         (nmat (send self :nmat))
         (nvar (send self :nvar))
         (matnames (send self :active-matrices '(all)))
         (matshapes (send self :active-shapes '(all)))
         (variables (send self :variables))
         (j 0))
      (dolist (i (send self :current-matrices '(all)))     
              (display-string 
               (format nil "~%Matrix: ~a~%Shape:  ~a~%" 
                       (select matnames j) (select matshapes j)) w)
              (print-matrix-to-window (send self :get-matrix i) w
                                      :row-labels variables
                                      :column-labels variables)
              (setf j (+ j 1)))
    w))

(defmeth diss-data-object-proto :data-info (w)
  (display-string (format nil "Data Summary Report~2%") w)
  (display-string (format nil "Title: ~a" (send self :title)) w)
  (display-string (format nil "~%Data:  ~a" (send self :name)) w)
  (display-string (format nil "~2%Data Type: ~a" 
                          (send self :data-type)) w)
  (display-string (format nil "~%Missing Values: ~a~%" 
                          (if (send self :missing-values) 
                              "Yes" "No")) w)
  (display-string (format nil "~%Number of Observations  = ~d" 
                          (send self :active-nobs)) w)
  (display-string (format nil "~%Number of Row & Columns = ~d" 
                       (send self :active-nvar '(all))) w)
  (display-string (format nil "~%Number of Matrices      = ~d~%"
                          (send self :active-nmat '(all))) w)
  (display-string (format nil "Data Matrices: ~%") w)
  )



#|_____________________________________________________________________
 |
 | DEFPROTO DISS-DATA-SUPERVISOR-PROTO
 |_____________________________________________________________________
 |#


(defproto diss-data-supervisor-proto '(supervisor) () diss-data-object-proto)

(defmeth diss-data-supervisor-proto :isnew (&rest args)
  (apply #'call-next-method args)
  (send self :statistical-object-type "dash")
  self)


(defmeth diss-data-supervisor-proto :statistical-object-type (&optional (logical nil set))
;written this way to prevent changing slot to invalid value
    (setf (slot-value 'statistical-object-type) "dash")
    (slot-value 'statistical-object-type))

(defmeth diss-data-supervisor-proto :supervisor (&optional (object nil set))
  (if set (setf (slot-value 'supervisor) object))
  (slot-value 'supervisor))

(defmeth diss-data-supervisor-proto :make-datasheet (&rest args)
   (let* ((dash (apply #'call-next-method args)))
     ; (send self :set-current-datasupervisor self)
     (send self :statistical-object-type "dash")
     dash));fwy changed from self 10-01-02

(defmeth diss-data-supervisor-proto :hide-datasheet ()
  (send (send self :datasheet) :hide-window))

(defmeth diss-data-supervisor-proto :show-datasheet ()
  (send (send self :datasheet) :show-window))

(defmeth diss-data-supervisor-proto :create-data ()
    (send (send self :datasheet) :create-data))

(defmeth diss-data-supervisor-proto :save-data-on-workmap (&rest args)
  (send (send self :datasheet) :save-data-on-workmap))

(defmeth diss-data-supervisor-proto :save-data-as ()
  (send (send self :datasheet) :save-data-as))
  

(defmeth diss-data-supervisor-proto :set-current-datasupervisor (&optional (object nil object?) 
                                                                   &key (update-workmap t))
  (cond
    ((and (not object) object?)
     (set-current-data-variables nil)
     nil)
    ((not object) *current-datasupervisor*)
    (object
     (send self :set-current-data-variables)
     (send (send *vista* :var-window-object) :clear)
     (send (send *vista* :obs-window-object) :clear)
     ;(send self :set-menu&tool-states "Disabled");statement deleted fwy 10-01-02
     ;(send *workmap* :do-click 5000 5000 nil nil);statement deleted fwy 10-01-02
     self)))
  

(defmeth diss-data-supervisor-proto :setcdsp (&optional (object nil object?)
                                                  &key (update-workmap t))
  (if object?
      (send self :set-current-datasupervisor object :update-workmap update-workmap)
      (send self :set-current-datasupervisor :update-workmap update-workmap)
      ))


(defmeth diss-data-supervisor-proto :set-current-data-variables ()
  (send self :set-symbols)
  (unless (send self :$)
          (when (send self :full-name)
                (set (intern (string-upcase (send self :full-name))) self))
          (when (send self :name)
                (set (intern (string-upcase (send self :name))) self ))
          (when (send self :proper-name)
                (set (intern (string-upcase (send self :proper-name))) self ))
          (send self :$ self)
          )
  (send self :full-name))


(defmeth diss-data-supervisor-proto :set-symbols ()
  (setf *current-datasupervisor* self)
  (setf  current-datasupervisor  self)
  (setf  current-databuffer  self)
  (setf *current-databuffe*  self)
  (setf *cdsupr* self)
  (setf  cdsupr  self)
  (setf *cdsp*   self)
  (setf  cdsp    self)
  (setf *cdman*  self)
  (setf *cdm*    self)
  (setf  cdman   self)
  (setf  cdm     self)
  (setf *cdb*    self)
  (setf  cdbufr  self)
  (setf  cdb     self)
  (setf *co* self)
  (setf  co  self)
  (setf *current-object* self)
  (setf  current-object  self)
  (setf @ self)
  self)



(defmeth diss-data-supervisor-proto :create-data ()
    (send (send self :datasheet) :create-data))

(defmeth diss-data-supervisor-proto :save-data-on-workmap (&rest args)
  (send (send self :datasheet) :save-data-on-workmap))

(defmeth diss-data-supervisor-proto :save-data-as ()
  (send (send self :datasheet) :save-data-as))
  
(defmeth diss-data-supervisor-proto :known-as (&optional (name-string))
  (call-next-method name-string))



  

  
(defmeth diss-data-supervisor-proto :print (&rest args)
  (format t "~a" (send self :full-name)))
    
(defmeth diss-data-supervisor-proto :window-menu-item  (&optional (objid nil set))
  (if set (setf (slot-value  'window-menu-item) objid))
  (slot-value 'window-menu-item))


(defmeth diss-data-supervisor-proto :make-vistatype ()
  (if (equal "matrix" (string-downcase (send self :data-type)))
      (format nil "RelaBufr[~ax~a]" 
              (* (send self :nobs) (send self :nmat))
              (send self :nobs))
      (format nil "RelaBufr[~ax~a]" (send self :nobs) (send self :nvar))))

                                   
(defmeth diss-data-supervisor-proto :make-object-id (&key (subject nil)) 
  (format nil "#<~a: ~a   ;StatObj: ~a>"
          (if subject subject "Object")
          (if (send self :known-as)
              (send self :known-as)
              (send self :proper-name))
          (send self :make-vistatype)))


(defmeth diss-data-supervisor-proto :object-id (&optional (objid nil set))
"Message args: (&optional logical)
 Sets or retrieves the object id string."
  (when (not (slot-value 'object-id)) 
        (slot-value 'object-id (send self :make-object-id)))
  (if set (setf (slot-value 'object-id) objid))
  (slot-value 'object-id))

(defmeth diss-data-supervisor-proto :make-names (name)
  (let* ((temp (get-sob-extension  name))
         (version (third temp))
         (temp (second temp))
         (extension "buf")
         (proper-name (proper-name temp extension version))
         (full-name proper-name)
         (elipsis-name (elipsis-name full-name)))
    (send self :name temp)
    (send self :extension extension)
    (send self :full-name full-name)
    (send self :proper-name proper-name)
    (send self :elipsis-name (elipsis-name (send self :proper-name)))
  ;  (send self :name temp)
  ;  (send self :proper-name nil)
  ;  (send self :proper-name (send self :make-proper-name))
    (send self :full-name (send self :proper-name))
    (set (intern (string-upcase full-name)) self)
    (set (intern (string-upcase temp)) self)
    (set (intern (string-upcase proper-name)) self)
    (set (intern (string-upcase elipsis-name)) self)
    (send self :object-id nil)
    (send self :make-object-id)
    (send self :proper-name)))

(defmeth diss-data-supervisor-proto :make-proper-name ()
    (proper-name (first (parse-name (send self :name))) "buf"))

(defmeth diss-data-supervisor-proto :proper-name (&optional (str nil set))
   (when (not (slot-value 'proper-name)) 
         (slot-value 'proper-name (send self :make-proper-name)))
  (if set (setf (slot-value 'proper-name) str))
  (slot-value 'proper-name))
          
(defmeth diss-data-supervisor-proto :info (&optional (stream *standard-output*)
                                               &key (verbose nil) (subject nil))
  (if (or *history* verbose)
      (unless (equal (string-downcase (send self :name)) "hidden")
              (format stream  "~%; ~a: Name:      ~a~%" 
                      (if subject subject "Object") 
                      (send self :proper-name))
              (format stream  ";         DataFile:  ~a~%" 
                      (if (not (send self :datafile))
                          (send self :datafile
                                (send *workmap* :datafile))
                          (if (send self :datafile)
                              (send self :datafile) 
                              "[Not Saved To File]")))
              (format stream  ";         StObjType:  ~a~%" (send self :make-vistatype))
              (format stream  ";         ProtoType: ~a~%" 
                      (string-capitalize 
                       (send self :slot-value 'proto-name)))
              (format stream  ";         Address:   ~d~%" (address-of self))
              (format stream  ";         Created:   ~a~%" 
                      (send self :slot-value 'instance-info))
              (format stream  ";         Elapsed:   ~,4d seconds~%" 
                      (fuzz (send self :elapsed-time) 3)))
        (format stream "; ~a: ~a; ~a~%> "
          (if subject subject "Buffer")
          (if (send self :known-as)
              (send self :known-as)
              (send self :full-name))
          (send self :make-vistatype))))


